Language/OS - Multiplatform Resource Library/LANGUAGE OS.iso/prolog/modprolg/mod-prol.lha/Prolog/modlib/src/$setof.P

Text File | 1992-05-27 | 15.2 KB | 424 lines

/* $setof.P */

%   File   : SETOF.PL
%   Author : R.A.O'Keefe
%   Updated: 17 November 1983
%   Purpose: define set_of/3, bag_of/3, findall/3, and findall/4
%   Needs  : Not.Pl
%
%   Modified for SB-Prolog by Saumya K. Debray, May 1988.
%   Some of the code for the SB-Prolog version, specifically
%   the version of $findall/3 using buff_code, was written by
%   David S. Warren (in 1986?).

/*  This file defines two predicates which act like setof/3 and bagof/3.
    I have seen the code for these routines in Dec-10 and in C-Prolog,
    but I no longer recall it, and this code was independently derived
    in 1982 by me and me alone.

    Most of the complication comes from trying to cope with free variables
    in the Filter; these definitions actually enumerate all the solutions,
    then group together those with the same bindings for the free variables.
    There must be a better way of doing this.  I do not claim any virtue for
    this code other than the virtue of working.  In fact there is a subtle
    bug: if setof/bagof occurs as a data structure in the Generator it will
    be mistaken for a call, and free variables treated wrongly.  Given the
    current nature of Prolog, there is no way of telling a call from a data
    structure, and since nested calls are FAR more likely than use as a
    data structure, we just put up with the latter being wrong.  The same
    applies to negation.

    Would anyone incorporating this in their Prolog system please credit
    both me and David Warren;  he thought up the definitions, and my
    implementation may owe more to subconscious memory of his than I like
    to think.  At least this ought to put a stop to fraudulent claims to
    having bagof, by replacing them with genuine claims.

    Thanks to Dave Bowen for pointing out an amazingly obscure bug: if
    the Template was a variable and the Generator never bound it at all
    you got a very strange answer!  Now fixed, at a price.
*/

/****************************************************************************
 *                                                                          *
 * This file has been changed by to include Modules Extensions              *
 * Changes by : Brian Paxton 1991/92                                        *
 * Last update : June 1992                                                  *
 *                                                                          *
 * Organisation : University of Edinburgh.                                  *
 * For : Departments of Computer Science and Artificial Intelligence        *
 *       Fourth Year Project.                                               *
 *                                                                          *
 ****************************************************************************/

% I have simply tidied up this file, as much of the original was unused.
% B Paxton

$setof_export([$setof/3,$bagof/3,$findall/3,$sort/2,$keysort/2,'^'/2]).

% $setof_use : $meta $buff $bmeta

%   findall(Template, Generator, List)
%   is a special case of bagof, where all free variables in the
%   generator are taken to be existentially quantified.  It is
%   described in Clocksin & Mellish on p152.  The code they give
%   has a bug (which the Dec-10 bagof and setof predicates share)
%   which this has not.

% SB-Prolog doesn't have record/recorded, so we use buff_code.

% B Paxton - Actually it has, but they are pretty basic, and do not
%            deallocate their space after items have been removed.
%            Too many calls to findall, bagof or setof would fill the
%            permanent program space!

$findall(T,Call,Result) :-
    $alloc_heap(10000,Buff),
    $findall_1(T,Call,Result,Buff).

$findall_1(T,Call,Result,Buff) :-
    $copyterm([],Buff,8,4,_), /* init result list to empty */
    $buff_code(Buff,0,2 /*pn*/ ,8), /* init where to put next answer */
    $buff_code(Buff,4,2 /*pn*/ ,12), /* init first free place */
    call(Call),
    $buff_code(Buff,0,5 /*gn*/ ,Place), /* get where to put answer */
    $buff_code(Buff,4,5 /*gn*/ ,Start), /* get first free place */
    $copyterm([T],Buff,Place,Start,End),
    Tailloc is Start+4,
    $buff_code(Buff,0,2 /*pn*/ ,Tailloc), /* where to put next answer */
    $buff_code(Buff,4,2 /*pn*/ ,End), /* next first free place */
    fail.

$findall_1(_,_,Result,Buff) :-
    $buff_code(Buff,4,5 /*gn*/ ,Length), /* Length =\= 12 fail if [] */
    $trimbuff(Length,Buff,1),
    $buff_code(Buff,8,18 /*vtb*/ ,Result).


%   $setof(Template, Generator, Set)
%   finds the Set of instances of the Template satisfying the Generator.
%   The set is in ascending order (see compare/3 for a definition of
%   this order) without duplicates, and is non-empty.  If there are
%   no solutions, set_of fails.  set_of may succeed more than one way,
%   binding free variables in the Generator to different values.  This
%   predicate is defined on p51 of the Dec-10 Prolog manual.

$setof(Template, Filter, Set) :-
    $bagof(Template, Filter, Bag),
    $sort(Bag, Set).



%   $bagof(Template, Generator, Bag)
%   finds all the instances of the Template produced by the Generator,
%   and returns them in the Bag in they order in which they were found.
%   If the Generator contains free variables which are not bound in the
%   Template, it assumes that this is like any other Prolog question
%   and that you want bindings for those variables.  (You can tell it
%   not to bother by using existential quantifiers.)
%   bag_of records three things under the key '.':
%    the end-of-bag marker           -
%    terms with no free variables   -Term
%    terms with free variables   Key-Term
%   The key '.' was chosen on the grounds that most people are unlikely
%   to realise that you can use it at all, another good key might be ''.
%   The original data base is restored after this call, so that set_of
%   and bag_of can be nested.  If the Generator smashes the data base
%   you are asking for trouble and will probably get it.
%   The second clause is basically just findall, which of course works in
%   the common case when there are no free variables.
%
% SB-Prolog version modified to use findall instead of record/recorded - SKD
%

$bagof(Template, Generator, Bag) :-
    $free_variables(Generator, Template, [], Vars),
    Vars \= [],
    !,
    Key =.. [.|Vars],
    $functor(Key, ., N),
        $findall(Key-Template,Generator,OmniumGatherum),
    $keysort(OmniumGatherum, Gamut), !,
    $concordant_subset(Gamut, Key, Answer),
    Bag = Answer.
$bagof(Template, Generator, Bag) :-
        $findall(Template,Generator,Bag).

%   There is a bug in the compiled version of arg in Dec-10 Prolog,
%   hence the rather strange code.  Only two calls on arg are needed
%   in Dec-10 interpreted Prolog or C-Prolog.

$replace_key_variables(0, _, _) :- !.
$replace_key_variables(N, OldKey, NewKey) :-
    arg(N, NewKey, Arg),
    nonvar(Arg), !,
    M is N-1,
    $replace_key_variables(M, OldKey, NewKey).
$replace_key_variables(N, OldKey, NewKey) :-
    arg(N, OldKey, OldVar),
    arg(N, NewKey, OldVar),
    M is N-1,
    $replace_key_variables(M, OldKey, NewKey).



%   $concordant_subset([Key-Val list], Key, [Val list]).
%   takes a list of Key-Val pairs which has been keysorted to bring
%   all the identical keys together, and enumerates each different
%   Key and the corresponding lists of values.

$concordant_subset([Key-Val|Rest], Clavis, Answer) :-
    $concordant_subset(Rest, Key, List, More),
    $concordant_subset(More, Key, [Val|List], Clavis, Answer).


%   $concordant_subset(Rest, Key, List, More)
%   strips off all the Key-Val pairs from the from of Rest,
%   putting the Val elements into List, and returning the
%   left-over pairs, if any, as More.

$concordant_subset([Key-Val|Rest], Clavis, [Val|List], More) :-
    Key == Clavis,
    !,
    $concordant_subset(Rest, Clavis, List, More).
$concordant_subset(More, _, [], More).


%   $concordant_subset/5 tries the current subset, and if that
%   doesn't work if backs up and tries the next subset.  The
%   first clause is there to save a choice point when this is
%   the last possible subset.

$concordant_subset([],   Key, Subset, Key, Subset) :- !.
$concordant_subset(_,    Key, Subset, Key, Subset).
$concordant_subset(More, _,   _,   Clavis, Answer) :-
    $concordant_subset(More, Clavis, Answer).


%   File   : NOT.PL
%   Author : R.A.O'Keefe
%   Updated: 17 November 1983
%   Purpose: "suspicious" negation

/*  This file defines a version of 'not' which checks that there are
    no free variables in the goal it is given to "disprove".  Bound
    variables introduced by the existential quantifier ^ or set/bag
    dummy variables are accepted.  If any free variables are found,
    a message is printed on the terminal and a break level entered.

    It is intended purely as a debugging aid, though it shouldn't slow
    interpreted code down much.  There are several other debugging
    aids that you might want to use as well, particularly
    unknown(_, trace)
    which will detect calls to undefined predicates (as opposed to
    predicates which have clauses that don't happen to match).

    The predicate $free_variables/4 defined in this files is also used
    by the set_of/bag_of code.

    Note: in Dec-10 Prolog you should normally use "\+ Goal" instead
    of "not(Goal)".  In C-Prolog you can use either, and would have to
    do some surgery on pl/init to install this version of "not".  The
    reason that I have called this predicate "not" is so that people
    can choose whether to use the library predicate not/1 (in Invoca.Pl)
    or this debugging one, not because I like the name.
*/


%   In order to handle variables properly, we have to find all the
%   universally quantified variables in the Generator.  All variables
%   as yet unbound are universally quantified, unless
%    a)  they occur in the template
%    b)  they are bound by X^P, setof, or bagof
%   $free_variables(Generator, Template, OldList, NewList)
%   finds this set, using OldList as an accumulator.

$free_variables(Term, Bound, VarList, [Term|VarList]) :-
    var(Term),
    $term_is_free_of(Bound, Term),
    $list_is_free_of(VarList, Term),
    !.
$free_variables(Term,_Bound, VarList, VarList) :-
    var(Term),
    !.
$free_variables(Term, Bound, OldList, NewList) :-
    $explicit_binding(Term, Bound, NewTerm, NewBound),
    !,
    $free_variables(NewTerm, NewBound, OldList, NewList).
$free_variables(Term, Bound, OldList, NewList) :-
    $functor(Term, _, N),
    $free_variables(N, Term, Bound, OldList, NewList).

$free_variables(0,_Term,_Bound, VarList, VarList) :- !.
$free_variables(N, Term, Bound, OldList, NewList) :-
    arg(N, Term, Argument),
    $free_variables(Argument, Bound, OldList, MidList),
    M is N-1, !,
    $free_variables(M, Term, Bound, MidList, NewList).

%   $explicit_binding checks for goals known to existentially quantify
%   one or more variables.  In particular \+ is quite common.

$explicit_binding(\+ _Goal,           Bound, fail,    Bound      ) :- !.
$explicit_binding(not(_Goal),           Bound, fail,    Bound       ) :- !.
$explicit_binding(Var^Goal,           Bound, Goal,    Bound+Var) :- !.
$explicit_binding(setof(Var,Goal,Set),  Bound, Goal-Set, Bound+Var) :- !.
$explicit_binding(bagof(Var,Goal,Bag),  Bound, Goal-Bag, Bound+Var) :- !.
$explicit_binding(set_of(Var,Goal,Set), Bound, Goal-Set, Bound+Var) :- !.
$explicit_binding(bag_of(Var,Goal,Bag), Bound, Goal-Bag, Bound+Var) :- !.


$term_is_free_of(Term, Var) :-
    var(Term), !,
    Term \== Var.
$term_is_free_of(Term, Var) :-
    $functor(Term, _, N),
    $term_is_free_of(N, Term, Var).

$term_is_free_of(0,_Term,_Var) :- !.
$term_is_free_of(N, Term, Var) :-
    arg(N, Term, Argument),
    $term_is_free_of(Argument, Var),
    M is N-1, !,
    $term_is_free_of(M, Term, Var).


$list_is_free_of([Head|Tail], Var) :-
    Head \== Var,
    !,
    $list_is_free_of(Tail, Var).
$list_is_free_of([], _).

/*======================================================================*/

/* This routine copies a term into a buffer. It is passed:
    Term: the term to copy,
    Buffer: the buffer to copy it into,
    Worddisp: the word of the buffer in which to put the copy (or
        a pointer to the copy.)
    Start: the disp of the next free location in the buffer, before the
        copy is done.
    End: (returned) the location of the first free location after the
        copying.

    Variables are copied into the buffer and the copied variables are
    pointed into the buffer and trailed. Thus later binding of these
    `outside' variables will cause the copied variables to be changed,
    too. If, however, the $copyterm call is failed over, the variables
    in the buffer will be ``disconnected'' from the outer variables.

    Copyterm is a prime candidate for moving down into the simulator as
    a builtin written in C.
*/


$copyterm(Term,Buff,Worddisp,Start,Start) :-
    var(Term),!,$buff_code(Buff,Worddisp,17 /*pvar*/ ,Term).

$copyterm(Term,Buff,Worddisp,Start,Start) :-
    number(Term),!,$buff_code(Buff,Worddisp,14 /*ptv*/ ,Term).

$copyterm(Term,Buff,Worddisp,Start,Start) :-
    $atom(Term),!,$buff_code(Buff,Worddisp,14 /*ptv*/ ,Term).

$copyterm(Term,Buff,Worddisp,Start,End) :-
    Term=[_|_],!,
    $buff_code(Buff,Worddisp,16 /*ptl*/ ,Start), /* ptr to list rec */
    Newstart is Start+8, /* reserve rec space */
    $copyargs(Term,1,2,Buff,Start,Newstart,End).

$copyterm(Term,Buff,Worddisp,Start,End) :-
    $structure(Term),!,
    $buff_code(Buff,Worddisp,15 /*ptp*/ ,Start), /* ptr to str rec */
    $buff_code(Buff,Start,0 /*ppsc*/ ,Term), /* rec psc ptr */
    Argsloc is Start+4,
    $arity(Term,Arity),Newstart is Argsloc+4*Arity, /* reserve rec space*/
    $copyargs(Term,1,Arity,Buff,Argsloc,Newstart,End).

$copyargs(Term,Argno,Maxargs,Buff,Argloc,Start,End) :-
    Argno > Maxargs,
     Start=End;
    Argno =< Maxargs,
     arg(Argno,Term,Arg),$copyterm(Arg,Buff,Argloc,Start,Mid),
     Nargno is Argno+1, Nargloc is Argloc+4,
     $copyargs(Term,Nargno,Maxargs,Buff,Nargloc,Mid,End).


$sort(L,R) :- $length(L,N), $sort(N,L,_,R).

$sort(N,U,L,R) :-
    N > 2 ->
        (N1 is N >> 1, N2 is N-N1,
         $sort(N1,U,L2,R1),
         $sort(N2,L2,L,R2),
         $merge(R1,R2,R)
        ) ;
        (N =:= 2 ->
            (U = [X1|L1],
             L1 = [X2|L],
             compare(Delta,X1,X2),
             (Delta ?= (<) -> R = [X1,X2] ;
              Delta ?= (>) -> R = [X2,X1] ;
                        R = [X2]
             )
            ) ;
            (N =:= 1 ->
                (U = [X|L], R = [X]) ;
                (U = L, R = [])        /* N == 0 */
            )
         ).

$merge(R1,R2,R3) :-
   R1 ?= [] ->
       R3 = R2 ;
   R2 ?= [] ->
       R3 = R1 ;
       (R1 = [X1|R1a], R2 = [X2|R2a], R3 = [X|R],
        compare(Delta,X1,X2),
        (Delta ?= (<) ->
            (X = X1, $merge(R1a,R2,R)) ;
            (Delta ?= (>) ->
                (X = X2, $merge(R1,R2a,R)) ;
            (X = X1, $merge(R1a,R2a,R))
            )
    )
       ).

/* Sorting on keys by bisecting and merging. */

$keysort(L,R) :- $length(L,N), $keysort(N,L,_,R1), R=R1.

$keysort(N,U,L,R) :-
    N > 2 ->
         (N1 is N >> 1, N2 is N-N1,
          $keysort(N1,U,L2,R1),
             $keysort(N2,L2,L,R2),
             $keymerge(R1,R2,R)
         ) ;
        (N =:= 2 ->
         (U = [X1|L1],
          L1 = [X2|L],
          $compare_keys(Delta,X1,X2),
          (Delta ?= (>) -> R = [X2,X1] ; R = [X1,X2])
         ) ;
    (N =:= 1 ->
         (U = [X|L], R = [X]) ;
         (U = L, R = [])        /* N == 0 */
         )).

$keymerge([],R,R) :- !.
$keymerge(R,[],R) :- !.
$keymerge(R1,R2,[X|R]) :-
   R1 = [X1|R1a], R2 = [X2|R2a],
   $compare_keys(Delta,X1,X2),
  (Delta ?= (>) ->
       (X = X2, $keymerge(R1,R2a,R)) ;
       (X = X1, $keymerge(R1a,R2,R))
  ).

$compare_keys(Delta,K1-X1,K2-X2) :- compare(Delta,K1,K2).

X^P :- call(P).

/* ------------------------------ $setof.P ------------------------------ */